home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / resources.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  7.1 KB  |  211 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;
  3. ;; resources.lisp
  4. ;;
  5. ;; Simple resource accessors
  6. ;;
  7.  
  8. ;;;;;;;;;;;;;;;;
  9. ;;
  10. ;; Modification History
  11. ;;
  12. ;; 04/28/93 mwp Release
  13. ;; 04/24/92 bill export get-string & get-ind-string (thanx to Bob Strong)
  14. ;; ------------- 2.0
  15. ;; 12/12/91 gb   %signal-error -> %err-disp.
  16. ;; 12/12/91 bill get-resource defaults to loading the resource
  17. ;; ------------- 2.0b4
  18. ;; 11/20/91 bill open-resource-file now resolves aliases
  19. ;; 09/27/91 bill $fnfErr & friends -> #$fnfErr & #friends
  20. ;; 07/05/91 bill New file
  21. ;;
  22.  
  23.  
  24. (in-package :ccl)
  25.  
  26. (eval-when (:compile-toplevel :load-toplevel :execute)
  27.   (export '(with-open-resource-file open-resource-file close-resource-file
  28.              use-resource-file current-resource-file using-resource-file
  29.              get-resource load-resource release-resource
  30.              add-resource delete-resource remove-resource
  31.              get-string get-ind-string)))
  32.  
  33.  
  34. ; Execute the BODY with REFNUM-VAR bound to the refnum for the resource
  35. ; file of FILE.  :IF-DOES-NOT-EXIST can be NIL, :ERROR, or :CREATE
  36. (defmacro with-open-resource-file ((refnum-var file &key (if-does-not-exist :error))
  37.                                    &body body)
  38.   `(let ((,refnum-var nil))
  39.      (unwind-protect
  40.        (progn
  41.          (setq ,refnum-var
  42.                (open-resource-file ,file :if-does-not-exist ',if-does-not-exist))
  43.          ,@body)
  44.        (if ,refnum-var
  45.          (close-resource-file ,refnum-var)))))
  46.  
  47. ; Open the resource FILE and return it's refnum.
  48. ; if-does-not-exist can be :error, nil or :create (just like OPEN).
  49. ; If ERRORP is NIL and there is an error, return two values: NIL and
  50. ; the error code.
  51. (defun open-resource-file (file &key (if-does-not-exist :error) (errorp t))
  52.   (let ((real-file (probe-file file)))          ; resolve alias
  53.     (setq real-file (mac-namestring (or real-file file)))
  54.     (with-pstr (pf (mac-namestring real-file))
  55.       (let ((res (#_OpenResFile pf)))
  56.         (declare (fixnum res))
  57.         (when (< res 0)
  58.           (flet ((err (code)
  59.                    (if errorp
  60.                      (signal-file-error code file)
  61.                      (return-from open-resource-file (values nil code)))))
  62.             (declare (dynamic-extent #'err))
  63.             (let ((code (#_ResError)))
  64.               (unless (or (eq code #$fnfErr)
  65.                           (eq code #$eofErr)
  66.                           (eq code #$resFNotFound))
  67.                 (err code))
  68.               (case if-does-not-exist
  69.                 (:create
  70.                  (#_CreateResFile pf)
  71.                  (setq res (#_OpenResFile pf))
  72.                  (when (< res 0) (err (#_ResError))))
  73.                 (:error
  74.                  (err code))
  75.                 ((nil) (return-from open-resource-file nil))
  76.                 (t (error (%badarg if-does-not-exist '(member nil :create :error))))))))
  77.         res))))
  78.  
  79. ; Close the resource file with the given refnum
  80. (defun close-resource-file (refnum)
  81.   (#_CloseResFile refnum)
  82.   (res-error))
  83.  
  84. ; General error checker for resource manager traps
  85. (defun res-error ()
  86.   (let ((err (#_ResError)))
  87.     (unless (eql 0 err)
  88.       (%err-disp err))))
  89.  
  90. ; Use the resource file with the given refnum
  91. (defun use-resource-file (refnum)
  92.   (prog1
  93.     (#_CurResFile)
  94.     (#_UseResFile refnum)
  95.     (res-error)))
  96.  
  97. (defmacro using-resource-file (refnum &body body)
  98.   (let ((old-refnum (gensym)))
  99.     `(let (,old-refnum)
  100.        (unwind-protect
  101.          (progn
  102.            (setq ,old-refnum (use-resource-file ,refnum))
  103.            ,@body)
  104.          (when ,old-refnum
  105.            (use-resource-file ,old-refnum))))))
  106.  
  107. (defun current-resource-file ()
  108.   (#_CurResFile))
  109.  
  110. ; Get a resource with the given type and name-or-number.
  111. ; (string type) should be a four-character string
  112. ; name-or-number should be an integer or a string
  113. ; if used-file-only? is true, Get1Resource is used instead of GetResource.
  114. ; if load? is true (the default), load the resource as well.
  115. ; Return NIL if the resource is not found for any reason.
  116. (defun get-resource (type name-or-number &optional 
  117.                           used-file-only?
  118.                           (load? t))
  119.   (let ((res (if (integerp name-or-number)
  120.                (if used-file-only?
  121.                  (#_Get1Resource type name-or-number)
  122.                  (#_GetResource type name-or-number))
  123.                (with-pstr (ps name-or-number)
  124.                  (if used-file-only?
  125.                    (#_Get1NamedResource type ps)
  126.                    (#_GetNamedResource type ps))))))
  127.     (unless (%null-ptr-p res)
  128.       (when load?
  129.         (load-resource res))
  130.       res)))
  131.  
  132. ; Get the 'STR ' resource with the given NAME-OR-NUMBER
  133. (defun get-string (name-or-number &optional used-file-only? dont-release)
  134.   (let ((str (get-resource "STR " name-or-number used-file-only?)))
  135.     (when str
  136.       (unwind-protect
  137.         (%get-string str)
  138.         (unless dont-release (#_ReleaseResource str))))))
  139.  
  140. ; get the INDEX'th string from the 'STR#' resource with the given NAME-OR-NUMBER
  141. ; Returns NIL if there is no such 'STR#' resource.
  142. ; Returns two values, NIL and the number of strings in the resource, if there
  143. ; is a matching 'STR#' resource, but the INDEX is too big.
  144. ; INDEX starts at 1 to copy the broken Mac definition.
  145. (defun get-ind-string (name-or-number index &optional used-file-only? dont-release)
  146.   (unless (and (fixnump index) (>= index 1))
  147.     (report-bad-arg index '(fixnum 1 *)))
  148.   (let ((index (1- (the fixnum index)))
  149.         (str# (get-resource "STR#" name-or-number used-file-only? nil)))
  150.     (declare (fixnum index))
  151.     (when str#
  152.       (unwind-protect
  153.         (without-interrupts               ; don't want anyone to purge this resource
  154.          (load-resource str#)
  155.          (let ((count (%hget-word str#)))
  156.            (if (<= count index)
  157.              (values nil count)
  158.              (let ((offset 2))
  159.                (dotimes (i index)
  160.                  (declare (fixnum i))
  161.                  (setq offset (+ 1 offset (%hget-byte str# offset))))
  162.                (%get-string str# offset)))))
  163.         (unless dont-release (#_ReleaseResource str#))))))
  164.  
  165. ; Load a resource
  166. (defun load-resource (resource)
  167.   (#_LoadResource resource)
  168.   (res-error))
  169.  
  170. ; Release the given resource
  171. (defun release-resource (resource)
  172.   (#_ReleaseResource resource)
  173.   (res-error))
  174.  
  175. ; Add resource to the currently used resource
  176. (defun add-resource (resource type id &key name attributes)
  177.   (with-pstr (ps (or name ""))
  178.     (#_AddResource resource type id ps)
  179.     (res-error)
  180.     (when attributes
  181.       (#_SetResAttrs resource attributes)
  182.       (res-error))
  183.     resource))
  184.  
  185. (defun write-resource (resource)
  186.   (#_WriteResource resource)
  187.   (res-error))
  188.  
  189. (defun delete-resource (type id-or-name &optional (used-file-only? t))
  190.   (unwind-protect
  191.     (progn
  192.       (#_SetResLoad nil)
  193.       (let ((resource (get-resource type id-or-name used-file-only?)))
  194.         (when resource
  195.           (remove-resource resource)
  196.           (#_DisposHandle resource)
  197.           t)))
  198.     (#_SetResLoad t)))
  199.  
  200. ; Note that this does not free the memory allocated for the resource.
  201. (defun remove-resource (resource)
  202.   (using-resource-file (#_HomeResFile resource)
  203.     (#_RmveResource resource))
  204.   (res-error))
  205.  
  206. (defun detach-resource (resource)
  207.   (#_DetachResource resource)
  208.   (res-error))
  209.  
  210. (provide "RESOURCES")
  211.